home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / top / top.t < prev    next >
Encoding:
Text File  |  1990-05-07  |  12.7 KB  |  320 lines
  1. (herald (orbit_top top))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.     
  26. (define bogus-filename (->filename 'anonymous))
  27.  
  28. (define (orbit exp . env)
  29.   (let ((env (if env (car env) (repl-env))))
  30.     (bind ((*noise-flag* nil)
  31.            (*debug-flag* nil)
  32.            (*noise+error*    (error-output))
  33.            (*noise+terminal* null-port)
  34.            (*noise-stream*   null-port))
  35.       (receive (comex #f #f)
  36.                (compile `(,syntax/lambda () ,exp)
  37.                         standard-early-binding-env
  38.                         (env-syntax-table env)
  39.                         bogus-filename
  40.                         '(anonymous))
  41.         (instantiate-comex comex env)))))
  42.  
  43. (define (compile exp support syntax filename h)
  44.   (front-init support
  45.               (lambda ()
  46.                 (generate-init 
  47.                  (lambda () 
  48.                    (assemble-init 
  49.                     (lambda ()
  50.                       (really-compile exp syntax filename h))))))))
  51.  
  52. (define (really-compile exp syntax filename h)
  53.   (receive (tree infex)
  54.            (make-code-tree+support `(,syntax/lambda () ,exp) syntax)
  55.     (receive (a b c)
  56.              (analyze tree)
  57.       (generate tree)
  58.       (receive (code-vector debugex) (assemble)
  59.         (let ((comex (create-comex filename h a b c code-vector)))
  60.       (if (not *debug-flag*) (erase-all tree))
  61.       (return comex infex debugex))))))
  62.  
  63. (define (cl exp . debug?)
  64.   (let ((debug? (if (null? debug?) nil (car debug?))))
  65.     (cond ((not (procedure? exp))
  66.            (real-cl exp debug?))
  67.           ((disclose exp)
  68.            => (lambda (exp) (real-cl exp debug?)))
  69.           (else
  70.            (cl (error "cannot get source code for ~S" exp) debug?)))))
  71.  
  72. (define (real-cl exp debug?)
  73.   (bind ((*noise-flag* t)
  74.          (*debug-flag* debug?)
  75.          (*assembly-comments?* t)
  76.          (*noise+error*    (error-output))
  77.          (*noise+terminal* (terminal-output))
  78.          (*noise-stream*   (terminal-output)))
  79.     (cl-compile `(,syntax/lambda () ,exp)
  80.                 base-early-binding-env
  81.                 (orbit-syntax-table)
  82.                 bogus-filename
  83.                 '(cl))))
  84.  
  85. (define (cl-compile exp support syntax filename h)
  86.   (front-init support
  87.               (lambda ()
  88.                 (generate-init 
  89.                  (lambda () 
  90.                    (assemble-init 
  91.                     (lambda ()
  92.                       (really-compile exp syntax filename h)
  93.                       (quicklist))))))))
  94.  
  95. (define (make-node-tree exp)
  96.   (bind ((*debug-flag* nil)
  97.          (*noise-flag* nil)
  98.          (*noise+error*    (error-output))
  99.          (*noise+terminal* (terminal-output))
  100.          (*noise-stream*   (terminal-output)))
  101.     (front-init standard-early-binding-env
  102.                 (lambda ()
  103.                   (receive (tree supex)
  104.                            (make-code-tree+support `(,syntax/lambda () ,exp)
  105.                                                    standard-syntax-table)
  106.                     (ignore supex)
  107.                     tree)))))
  108.  
  109. (lset *object-file-extension* 'o)
  110. (lset *information-file-extension* 'i)
  111. (lset *noise-file-extension* 'n)
  112. (lset *debug-file-extension* 'd)
  113.  
  114. (define (compile-file file-spec)
  115.   (comfile-bind file-spec file-spec really-comfile))
  116.  
  117. (define comfile compile-file)
  118.  
  119. (define (comfile2 in-file-spec out-file-spec)
  120.   (comfile-bind in-file-spec out-file-spec really-comfile))
  121.  
  122. (define (totally-comfile in-file-spec out-file-spec read-table syntax support)
  123.   (comfile-bind in-file-spec
  124.                 out-file-spec
  125.                 (lambda (in-filename out-filename)
  126.                   (really-totally-comfile in-filename out-filename
  127.                                           read-table syntax support))))
  128.  
  129. (define (create-support in-file-spec . out-file-spec)
  130.   (comfile-bind in-file-spec
  131.                 (if (null? out-file-spec) in-file-spec (car out-file-spec))
  132.                 (lambda (in-filename out-filename)
  133.                   (receive (exp support syntax #f)
  134.                            (read-file in-filename)
  135.                     (front-init support
  136.                       (lambda ()
  137.                         (receive (tree infex)
  138.                           (make-code-tree+support `(,syntax/lambda () ,exp)
  139.                                                   syntax)
  140.                           (erase-all tree)
  141.                           (write-support-file infex out-filename))))))))
  142.  
  143. (define (comfile-bind in-file-spec out-file-spec cont)
  144.   (let ((in-filename (->filename in-file-spec)) 
  145.         (out-filename (->filename out-file-spec)))
  146.     (with-open-ports ((noise-stream
  147.                        (open (filename-with-type out-filename
  148.                                                  *noise-file-extension*)
  149.                              '(out))))
  150.       (bind ((*debug-flag* nil)
  151.              (*noise-flag* nil)
  152.              (*noise+error* (make-broadcast-port noise-stream (error-output)))
  153.              (*noise+terminal* (make-broadcast-port noise-stream 
  154.                                                     (terminal-output)))
  155.              (*noise-stream* noise-stream))
  156.         (cont in-filename out-filename)))))
  157.  
  158. (define (really-comfile in-filename out-filename)
  159.     (receive (exp support syntax h)
  160.              (read-file in-filename)
  161.       (receive (comex infex debugex)
  162.                (compile exp support syntax in-filename h)
  163.         (write-support-file infex out-filename)
  164.         (write-object-file comex out-filename)
  165.     (write-debug-file debugex out-filename)
  166.         t)))
  167.  
  168. (define (really-totally-comfile in-filename out-filename read-table syntax support)
  169.   (receive (exp #f #f h)
  170.            (really-read-file in-filename read-table nil)
  171.     (receive (comex infex debugex)
  172.              (compile exp support syntax in-filename h)
  173.       (write-support-file infex out-filename)
  174.       (write-object-file comex out-filename)
  175.       (write-debug-file debugex out-filename)
  176.       t)))
  177.  
  178. (define (write-object-file comex filename)
  179.   (write-comex-to-file (filename-with-type filename *object-file-extension*)
  180.                        comex))
  181.  
  182. (define (write-debug-file debugex file)
  183.   (with-open-ports ((out (open (filename-with-type file 
  184.                            *debug-file-extension*)
  185.                    'dump)))
  186.     (write out debugex)))
  187.                            
  188. ;;; This isn't used anywhere
  189. ;;;(define-simple-switch orbit-macro-definition-env locale? user-env)
  190. ;;;(define tc-macro-definition-env orbit-macro-definition-env)
  191.  
  192. (define orbit-syntax-table
  193.   (make-simple-switch 'orbit-syntax-table
  194.                       true?
  195.                       (env-syntax-table user-env)))
  196.  
  197. (define tc-syntax-table orbit-syntax-table)
  198.  
  199. ;;; Bizarro new interface
  200.  
  201. (define (make-compiler id)
  202.   (let ((syntax standard-syntax-table)
  203.         (read standard-read-table)
  204.         (bindings standard-early-binding-env))
  205.     (object (lambda (from . to)
  206.               (totally-comfile from
  207.                                (if (null? to) from (car to))
  208.                                read syntax bindings))
  209.       ((compiler-syntax-table      self) syntax)
  210.       ((compiler-read-table        self) read)
  211.       ((compiler-early-binding-env self) bindings)
  212.       (((setter compiler-syntax-table) self new)
  213.        (set syntax new))
  214.       (((setter compiler-read-table) self new)
  215.        (set read new))
  216.       (((setter compiler-early-binding-env) self new)
  217.        (set bindings new))
  218.       ((identification self) id))))
  219.  
  220. (define-settable-operation compiler-syntax-table)
  221. (define-settable-operation compiler-read-table)
  222. (define-settable-operation compiler-early-binding-env)
  223.  
  224. (define (make-early-binding-locale super name)
  225.   (make-definition-env super name))
  226.  
  227. (define (make-empty-early-binding-locale name)
  228.   (make-definition-env false name))
  229.  
  230. (define (load-early-bindings file-spec . early-binding-env)
  231.   (let ((table (reload-support file-spec)))
  232.     (instantiate-definition-table (if (null? early-binding-env)
  233.                                       standard-early-binding-env
  234.                                       (car early-binding-env))
  235.                                   table)))
  236.  
  237. ;;; Reading the file in
  238.  
  239. (define (read-file filename)
  240.   (really-read-file filename nil t))
  241.  
  242. (define (really-read-file filename read-table herald?)
  243.   (with-open-ports ((input (open-source filename (source-file-extension))))
  244.     (let ((name (port-truename input)))
  245.       (format *noise+terminal* "~%;Beginning compilation on ")
  246.       (if (fx<= (fx+ (hpos *noise+terminal*) (print-width name))
  247.                 (line-length *noise+terminal*))
  248.           (format *noise+terminal* "~A~2%" name)
  249.           (format *noise+terminal* "~%; ~A~%" name)))
  250.     (let* ((first (read input))
  251.            (herald-obj (cond ((and (pair? first)
  252.                                    (eq? (car first) 'herald))
  253.                               (parse-herald (cadr first) (cddr first)))
  254.                              (herald?
  255.                               (error "file ~S has no herald form"
  256.                                      (filename->string filename)))
  257.                              (else nil))))
  258.       (bind (((port-read-table input) 
  259.                 (cond (read-table => identity)
  260.                       ((herald-read-table herald-obj)
  261.                        (eval (herald-read-table herald-obj) user-env))
  262.                       (else
  263.                        standard-read-table))))
  264.         (iterate loop ((forms '()) 
  265.                        (read-form (if herald-obj (read input) first)))
  266.           (cond ((not (eof? read-form))
  267.                  (loop (cons read-form forms) (read input)))
  268.                 (herald?
  269.                  (return `(,syntax/lambda () . ,(reverse! forms))
  270.                          (if (herald-environment herald-obj)
  271.                              (eval (herald-environment herald-obj) 
  272.                                    user-env)
  273.                              standard-early-binding-env)
  274.                          (if (herald-syntax-table herald-obj)
  275.                              (eval (herald-syntax-table herald-obj) 
  276.                                    user-env)
  277.                              (orbit-syntax-table))
  278.                          (cdr first)))
  279.                 (else
  280.                  (return `(,syntax/lambda () . ,(reverse! forms))
  281.                          nil nil
  282.                          (if herald-obj
  283.                              (cdr first) 
  284.                              (list (filename-name filename)))))))))))
  285.  
  286. (define (open-source filename extension)
  287.   (or (maybe-open filename '(in))
  288.       (maybe-open (filename-with-type filename extension) '(in))
  289.       (open filename '(in))))
  290.  
  291. (lset *modules* (make-table '*modules*))
  292.  
  293. (define (orbit-setup directory)
  294.   (set (table-entry *modules* 'base)       `(,directory base))
  295.   (set (table-entry *modules* 'locations)  `(,directory locations))
  296.   (set (table-entry *modules* 'carcdr)     `(,directory carcdr))
  297.   (set (table-entry *modules* 'predicates) `(,directory predicates))
  298.   (set (table-entry *modules* 'open)       `(,directory open))
  299.   (set (table-entry *modules* 'aliases)    `(,directory aliases))
  300.   (set (table-entry *modules* 'genarith)    `(,directory genarith))
  301.   t)
  302.  
  303. (define (module-name->filename name)
  304.   (->filename (cond ((table-entry *modules* name)
  305.                      => identity)
  306.                     ((and (pair? name)
  307.                      (table-entry *modules* (car name)))
  308.                      => (lambda (n)
  309.                           (cons n (cdr name))))
  310.                     (else name))))
  311.  
  312. ;;; FE/TOP
  313. (define (reload-support module-name)
  314.   (set (table-entry definition-tables module-name) '#f)
  315.   (get-definition-table module-name))
  316.  
  317.  
  318.     
  319.  
  320.